home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 September (IDG) / Sep99.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / package.tcl < prev    next >
Encoding:
Text File  |  1999-04-21  |  38.9 KB  |  1,306 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "package.tcl"
  6.  #                                    created: 2/8/97 {6:15:10 pm} 
  7.  #                                last update: 21/4/1999 {7:38:23 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997-1999  Vince Darley, all rights reserved
  15.  # 
  16.  #  How to ensure packages are loaded in the correct order?
  17.  #  (some may require Vince's Additions).  Here perhaps we could
  18.  #  just use a Tcl8-like-approach: introduce a 'package' command
  19.  #  and have stuff like 'package Name 1.0 script-to-load'.
  20.  #  Then a package can just do 'package require Othername' to ensure
  21.  #  it is loaded.  I like this approach.
  22.  #  
  23.  #  How to initialise each package at startup?  If we use the above
  24.  #  scheme, then the startup script is purely a sequence of
  25.  #  'package require Name' commands.  The file 'prefs.tcl' is then
  26.  #  purely for user-meddling.  Packages do not need to store anything
  27.  #  there.  Sounds good to me.
  28.  #  
  29.  #  How to uninstall things?  One approach here is a 
  30.  #  'package uninstall Name' command.  Nice packages would provide
  31.  #  this.
  32.  #  
  33.  #  We need a default behaviour too.  Some packages require no
  34.  #  installation at all (except placing in a directory), others 
  35.  #  require sourcing, others need to add something to a menu.  How
  36.  #  much of this should be automated and how much is up to the
  37.  #  package author?
  38.  # 
  39.  # ----
  40.  # 
  41.  #  The solution below is to imitate Tcl 8.  There is a 'package'
  42.  #  mechanism.  There exists a index::feature() array which gives for
  43.  #  each package the means to load it --- a procedure name or a
  44.  #  'source file' command.  The package index is compiled 
  45.  #  automatically by recursively scanning all files in the
  46.  #  Packages directory for 'package name version do-this'
  47.  #  commands.
  48.  #  
  49.  #  There's also 'package names', 'package exists name', and an
  50.  #  important 'package require name version' which allows one
  51.  #  package to autoload another...
  52.  #  
  53.  # Pros of this approach: many packages, which would otherwise
  54.  # require an installation procedure, now can be just dropped
  55.  # in to the packages directory and they're installed! (After
  56.  # rebuilding the package index).  This is because 'package'
  57.  # can declare a snippet of code, an addition to a menu etc…
  58.  # ----
  59.  # 
  60.  # Thanks to Tom Fetherston for some improvements here.
  61.  # ###################################################################
  62.  ##
  63.  
  64. namespace eval package {}
  65. namespace eval date {}
  66. namespace eval remote {}
  67.  
  68. ## 
  69.  # -------------------------------------------------------------------------
  70.  # 
  71.  # "alpha::findAllExtensions" --
  72.  # 
  73.  #  package require all extensions the user has activated
  74.  # -------------------------------------------------------------------------
  75.  ##
  76. proc alpha::findAllExtensions {} {
  77.     global global::features index::feature alpha::earlyPackages
  78.     # this carries out the existence part of each feature
  79.     foreach m [array names index::feature] {
  80.     if {[lsearch -exact [set alpha::earlyPackages] $m] != -1} {
  81.         continue
  82.     }
  83.     set info [set index::feature($m)]
  84.     if {[string trim [lindex $info 3]] != ""} {
  85.         try::level \#0 [lindex [set index::feature($m)] 3] -reporting log -while "initialising $m"
  86.         set index::feature($m) [lreplace [set index::feature($m)] 3 3 ""]
  87.     }
  88.     }    
  89.     # remove any package which doesn't exist.
  90.     foreach m [set global::features] {
  91.     if {![info exists index::feature($m)]} {
  92.         set global::features [lremove ${global::features} $m]
  93.     } elseif {[lindex [set index::feature($m)] 2] == 0} {
  94.         package::activate $m
  95.     }
  96.     }
  97. }
  98.  
  99. proc package::addPrefsDialog {pkg} {
  100.     global package::prefs alpha::noMenusYet
  101.     lunion package::prefs $pkg
  102.     if {![info exists alpha::noMenusYet]} {
  103.     # we were called after start-up; build the menu now
  104.     menu::buildSome packages
  105.     }
  106. }
  107.  
  108. ## 
  109.  # -------------------------------------------------------------------------
  110.  # 
  111.  # "alpha::package" --
  112.  # 
  113.  #  Mimics the Tcl standard 'package' command for use with Alpha.
  114.  #  It does however have some differences.
  115.  #  
  116.  #  package require ?-exact? ?-extension -mode -menu? name version
  117.  #  package exists ?-extension -mode -menu? name version
  118.  #  package names ?-extension -mode -menu?
  119.  #  package uninstall name version
  120.  #  package vcompare v1 v2
  121.  #  package vsatisfies v1 v2
  122.  #  package versions ?-extension -mode -menu? name
  123.  #  package type name
  124.  #  package info name
  125.  #  package maintainer name version {name email web-page}
  126.  #  package modes 
  127.  #  
  128.  #  Equivalent to alpha::mode alpha::menu and alpha::extension
  129.  #  
  130.  #  package mode ...
  131.  #  package menu ...
  132.  #  package extension ...
  133.  #  
  134.  #  For extensions only:
  135.  #  
  136.  #  package forget name version
  137.  # -------------------------------------------------------------------------
  138.  ##
  139. proc alpha::package {cmd args} {
  140.     global index::feature
  141.     switch -- $cmd {
  142.     "require" {
  143.         set info [package::getInfo "exact loose"]
  144.         global alpha::rebuilding
  145.         if {[llength $info]} {
  146.         if {!${alpha::rebuilding} && [set version [lindex $args 1]] != ""} {
  147.             if {[info exists exact]} {
  148.             if {[lindex $info 0] != $version} {
  149.                 error "requested exact $version, had [lindex $info 0]"
  150.             }
  151.             } elseif {[info exists loose]} {
  152.             if {[alpha::package vcompare [lindex $info 0] $version] < 0} {
  153.                 error "requested $version or newer, had [lindex $info 0]"
  154.             }
  155.             } elseif {![alpha::package vsatisfies [lindex $info 0] $version]} {
  156.             error "requested $version, had [lindex $info 0]"
  157.             }
  158.         }
  159.         if {$type == "feature"} {
  160.             global package::loaded alpha::noMenusYet \
  161.               errorCode errorInfo
  162.             package::activate $name
  163.         }
  164.         return [lindex $info 0]
  165.         }
  166.         if {!${alpha::rebuilding}} {
  167.         error "can't find package $name"
  168.         }
  169.     }
  170.     "uninstall" {
  171.         set name [lindex $args 0]
  172.         if {[llength $args] > 2} {
  173.         set version [lindex $args 1]
  174.         global alpha::rebuilding 
  175.         if {${alpha::rebuilding}} {
  176.             global rebuild_cmd_count index::uninstall pkg_file
  177.             switch -- [set script [lindex $args 2]] {
  178.             "this-file" {
  179.                 set script [list file delete $pkg_file]
  180.             }
  181.             "this-directory" {
  182.                 set script [list rm -r [file dirname $pkg_file]]
  183.             }
  184.             }
  185.             set index::uninstall($name) [list $version $pkg_file $script]
  186.             set args [lrange $args 3 end]
  187.             if {[llength $args]} {
  188.             eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  189.             return
  190.             }
  191.             if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  192.             return -code 11
  193.             }
  194.         }
  195.         } else {
  196.         cache::read index::uninstall
  197.         return [set index::uninstall($name)]
  198.         }
  199.     }
  200.     "forget" {
  201.         catch {unset index::feature($name)}
  202.     }
  203.     "exists" {
  204.         if {[package::getInfo] != ""} {return 1} else {return 0}
  205.     }
  206.     "type" {
  207.         if {[package::getInfo] != ""} {return $type} 
  208.         error "No such package"
  209.     }
  210.     "info" {
  211.         if {[llength [set info [package::getInfo]]]} {return [concat $type $info]} 
  212.         error "No such package"
  213.     }
  214.     "maintainer" -
  215.     "disable" -
  216.     "help" {
  217.         set name [lindex $args 0]
  218.         if {[llength $args] > 2} {
  219.         global alpha::rebuilding 
  220.         if {${alpha::rebuilding}} {
  221.             set version [lindex $args 1]
  222.             global rebuild_cmd_count index::$cmd
  223.             set data [lindex $args 2]
  224.             set index::${cmd}($name) [list $version $data]
  225.             set args [lrange $args 3 end]
  226.             if {[llength $args]} {
  227.             eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  228.             return
  229.             }
  230.             if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  231.             return -code 11
  232.             }
  233.         }
  234.         } else {
  235.         cache::read index::$cmd
  236.         return [set index::${cmd}($name)]
  237.         }
  238.     }
  239.     "versions" {
  240.         set info [package::getInfo]
  241.         if {[llength $info]} {
  242.         return [lindex $info 0]
  243.         }
  244.         error "No such package"
  245.     }
  246.     "vcompare" {
  247.         set c [eval package::_versionCompare $args]
  248.         if {$c > 0 || $c == -3} {
  249.         return 1
  250.         } elseif {$c == 0} {
  251.         return 0
  252.         } else {
  253.         return -1
  254.         }
  255.     }
  256.     "vsatisfies" {
  257.         if {[lindex $args 0] == "-loose"} {
  258.         set c [eval package::_versionCompare [lrange $args 1 end]]
  259.         return [expr {$c >= 0 || $c == -3 ? 1 : 0}]
  260.         } else {
  261.         set c [eval package::_versionCompare $args]
  262.         return [expr {$c >= 0 ? 1 : 0}]
  263.         }
  264.     }
  265.     "names" {
  266.         set names ""
  267.         package::getInfo
  268.         foreach type $which {
  269.         if {[array exists index::${type}]} {
  270.             eval lappend names [array names index::${type}]
  271.         }
  272.         }
  273.         return $names
  274.     }
  275.     "mode" -
  276.     "menu" -
  277.     "feature" {
  278.         eval alpha::$cmd $args
  279.     }
  280.     default {
  281.         error "Unknown option '$cmd' to 'package'"
  282.     }
  283.     }
  284. }
  285.  
  286. proc package::getInfo {{flags ""}} {
  287.     uplevel [list set flags $flags]
  288.     uplevel {
  289.     set name [lindex $args 0]
  290.     if {[regexp -- {-([^-].*)} $name "" which]} {
  291.         if {[lsearch $flags $which] != -1} {
  292.         set $which 1
  293.         set name [lindex $args 1]            
  294.         set args [lrange $args 1 end]            
  295.         return [package::getInfo $flags]
  296.         }
  297.         if {[lsearch {feature mode} $which] == -1} {
  298.         error "No such flag -$which"
  299.         }
  300.         set name [lindex $args 1]
  301.         set args [lrange $args 1 end]
  302.     } else {
  303.         set which {feature mode}
  304.     }
  305.     foreach type $which {
  306.         if {$type != "feature"} {cache::read index::${type}}
  307.         if {[info exists index::${type}($name)]} {
  308.         return [set index::${type}($name)]
  309.         }
  310.     }
  311.     return ""
  312.     }    
  313. }
  314.  
  315. ## 
  316.  # -------------------------------------------------------------------------
  317.  # 
  318.  # "package::_versionCompare" --
  319.  # 
  320.  #  This proc compares the two version numbers.  It returns:
  321.  #  
  322.  #  0 equal
  323.  #  1 equal but beta/patch update
  324.  #  2 equal but minor update
  325.  #  -1 beta/patch version older
  326.  #  -2 minor version older
  327.  #  -3 major version newer
  328.  #  -5 major version older
  329.  #  
  330.  #  i.e. >= 0 is basically ok, < 0 basically bad
  331.  #  
  332.  #  It works for beta, alpha, dev, fc and patch version numbers.
  333.  #  Any sequence of letters starting b,a,d,f,p are assumed to
  334.  #  represent the particular item.
  335.  #  
  336.  #  2.4 > 1.5 > 1.4.3 > 1.4.3b2 > 1.4.3b1 > 1.4.3a75 > 1.4p1 > 1.4
  337.  # -------------------------------------------------------------------------
  338.  ##
  339. proc package::_versionCompare {v1 v2} {
  340.     regsub -all -nocase {([a-z])[a-z]+} $v1 {\1} v1
  341.     regsub -all -nocase {([a-z])[a-z]+} $v2 {\1} v2
  342.     set v1 [split $v1 .p]
  343.     set v2 [split $v2 .p]
  344.     set i -1
  345.     set ret 0
  346.     set mult 2
  347.     while 1 {
  348.     incr i
  349.     set sv1 [lindex $v1 0]
  350.     set sv2 [lindex $v2 0]
  351.     if {$sv1 == "" && $sv2 == ""} { break }
  352.     if {$sv1 == ""} { 
  353.         set v1 [concat 8 0 $v1]
  354.         set v2 [concat 9 $v2]
  355.         continue
  356.     } elseif {$sv2 == ""} { 
  357.         set v1 [concat 9 $v1]
  358.         set v2 [concat 8 0 $v2]
  359.         continue
  360.     } elseif {[regexp -nocase {[a-z]} "$sv1$sv2"]} {
  361.         # beta versions
  362.         foreach v {sv1 sv2} {
  363.         if {[regexp -nocase {[a-z]} [set $v]]} {
  364.             # f = 8, b = 7, a = 6, d = 5
  365.             regsub -nocase {([^a-z])f} [set $v] {\1 7 } $v
  366.             regsub -nocase {([^a-z])b} [set $v] {\1 6 } $v
  367.             regsub -nocase {([^a-z])a} [set $v] {\1 5 } $v
  368.             regsub -nocase {([^a-z])d} [set $v] {\1 4 } $v
  369.         } else {
  370.             # release version = 8, so it is larger than any of the above
  371.             append $v " 8"
  372.         }
  373.         }
  374.         set v1 [eval lreplace [list $v1] 0 0 $sv1]
  375.         set v2 [eval lreplace [list $v2] 0 0 $sv2]
  376.         set mult 1
  377.         continue
  378.     }
  379.     if {$sv1 < $sv2} { set ret -1 ; break }
  380.     if {$sv1 > $sv2} { set ret 1 ; break }
  381.     set v1 [lrange $v1 1 end]
  382.     set v2 [lrange $v2 1 end]
  383.     }
  384.     if {$i == 0} {
  385.     # major version, return 0, -3, -5
  386.     return [expr {$ret * (-4*$ret + 1)}]
  387.     } else {
  388.     return [expr {$mult *$ret}]
  389.     }
  390. }
  391.  
  392. proc package::versionCheck {name vers} {
  393.     set av [alpha::package versions $name]
  394.     set c [package::_versionCompare $av $vers]
  395.     if {$c < 0 && $c != -3} {            
  396.     error "The installed version $av of '$name' is too old. Version $vers was requested."
  397.     } elseif {$c == -3} {            
  398.     error "The installed version $av of '$name' may not be backwards compatible with the requested version ($vers)."
  399.     }            
  400. }
  401.  
  402. proc package::reqInstalledVersion {name exact? {reqvers ""}} {
  403.     global index::feature
  404.     # called from installer
  405.     set msg " I suggest you abort the installation."
  406.     if {[info exists index::feature($name)]} {
  407.     if {[set exact?] == ""} {return}
  408.     set av [alpha::package versions $name]
  409.     if {[set exact?] == "-exact"} {
  410.         if {[alpha::package versions $name] != $reqvers} {
  411.         alertnote "The installed version $av of '$name' is incorrect.  Exact version $reqvers was requested.$msg"
  412.         }
  413.     } else {
  414.         set reqvers [set exact?]
  415.         if {$reqvers != ""} {        
  416.         set c [package::_versionCompare $av $reqvers]            
  417.         if {$c < 0 && $c != -3} {            
  418.             alertnote "The installed version $av of '$name' is too old. Version $reqvers was requested.$msg"
  419.         } elseif {$c == -3} {            
  420.             alertnote "The installed version $av of '$name' may not be backwards compatible with the requested version ($reqvers).$msg"
  421.         }             
  422.         }        
  423.     }
  424.     } else {
  425.     alertnote "This package requires the prior installation of '$name'. It is not currently installed.$msg"
  426.     }
  427. }
  428.  
  429. proc package::checkRequire {pkg} {
  430.     if {[catch {alpha::package require $pkg} error]} {
  431.     global errorInfo ; echo $errorInfo
  432.     if {[catch {alertnote "The '$pkg' package had an error starting up: $error"} ]} {
  433.         alertnote "The '$pkg' package had an error starting up"
  434.         echo $error
  435.     }
  436.     }    
  437. }
  438.  
  439.  
  440.  
  441. proc package::queryWebForList {} {
  442.     global defaultAlphaDownloadSite remote::site PREFS
  443.     set sitename [dialog::variable defaultAlphaDownloadSite "Query which site?"]
  444.     set nm [file join ${PREFS} _pkgtemp]
  445.     set siteurl [set remote::site($sitename)]
  446.     
  447.     catch {file delete $nm}
  448.     message "Fetching remote list…"
  449.     set type [url::fetch $siteurl $nm]
  450.     package::okGotTheList $sitename
  451. }
  452.  
  453. ## 
  454.  # -------------------------------------------------------------------------
  455.  # 
  456.  # "package::okGotTheList" --
  457.  # 
  458.  #  Helper proc which we can also call if the listing was interrupted
  459.  #  half-way through.
  460.  # -------------------------------------------------------------------------
  461.  ##
  462. proc package::okGotTheList {{sitename ""}} {
  463.     global defaultAlphaDownloadSite remote::site PREFS remote::lastsite
  464.     if {$sitename == ""} {
  465.     if {[info exists remote::lastsite]} {
  466.         set sitename ${remote::lastsite}
  467.         unset remote::lastsite
  468.     } else {
  469.         set sitename [dialog::variable defaultAlphaDownloadSite "From which site did you get the list?"]
  470.     }
  471.     }
  472.     set type [lindex [url::parse [set remote::site($sitename)]] 0]
  473.     set nm [file join ${PREFS} _pkgtemp]
  474.     if {![file exists $nm] || (![file writable $nm]) || (![file size $nm])} {
  475.     alertnote "It looks like that application returned control\
  476.       to me before the download was complete (otherwise there was an error)\
  477.       -- probably Netscape/IE.  When it's done, or if there was an error\
  478.       hit Ok."
  479.     }
  480.     if {![file exists $nm] || (![file writable $nm]) || (![file size $nm])} {
  481.     dialog::alert "There was a problem fetching the list --- if it's still\
  482.       being downloaded (you hit Ok too early!), wait till it's done \
  483.       and then select 'Ok Got The List'\
  484.       from the internet updates menu."
  485.     set remote::lastsite $sitename
  486.     enableMenuItem -m internetUpdates "Ok, Got The List" on
  487.     error "Error fetching list of new packages"
  488.     } else {
  489.     enableMenuItem -m internetUpdates "Ok, Got The List" off
  490.     }
  491.     set fd [open $nm "r"]
  492.     catch {set lines [split [read $fd] "\n\r"]}
  493.     close $fd
  494.     
  495.     if {[catch [list remote::process${type}Listing $lines] listing]} {
  496.     alertnote "Error interpreting list of new packages"
  497.     error "Error interpreting list of new packages"
  498.     }
  499.     message "Processing list…"
  500.     remote::processList $sitename $listing
  501.     message "Updated remote package information."
  502. }
  503.  
  504. proc package::active {pkg {text ""}} {
  505.     global global::features mode::features mode
  506.     if {[lsearch -exact ${global::features} $pkg] != -1 \
  507.       || ($mode != "" && ([lsearch -exact [set mode::features($mode)] $pkg] != -1))} {
  508.     if {[llength $text]} { return [lindex $text 0] } else {return 1 }
  509.     } else {
  510.     if {[llength $text]} { return [lindex $text 1] } else {return 0 }
  511.     }
  512. }
  513.  
  514. proc package::_editSite {{name ""} {loc ""}} {
  515.     if {$name == ""} {
  516.     set title "Name of new archive site"
  517.     set name "Ken's Alpha site"
  518.     set loc "ftp://ftp.ken.com/pub/Alpha/"
  519.     } else {
  520.     set title "Archive site name"
  521.     }
  522.     set y 10
  523.     set yb 105
  524.     set res [eval dialog -w 420 -h 135 \
  525.       [dialog::textedit $title $name 10 y 40] \
  526.       [dialog::textedit "URL for site" $loc 10 y 40] \
  527.       [dialog::okcancel 250 yb 0]]
  528.     if {[lindex $res 3]} { error "Cancel" } 
  529.     # cancel was pressed
  530.     return [lrange $res 0 1]    
  531. }
  532.  
  533.  
  534. proc package::addIndex {args} {
  535.     global index::feature pkg_file
  536.     cache::read index::feature
  537.     foreach f [concat $args] {
  538.     set pkg_file $f
  539.     message "scanning $f…"
  540.     catch {source $f}
  541.     }
  542.     cache::create index-extension "variable" index::feature
  543.     unset pkg_file
  544. }
  545.  
  546. proc package::helpFile {pkg {pointer 0}} {
  547.     # read help file instead
  548.     global HOME
  549.     set v [alpha::package versions $pkg]
  550.     if {[lindex $v 0] == "mode"} {
  551.     set v [lindex $v 1]
  552.     alertnote "The '$pkg' package is implemented by $v mode, and has no separate help.  I'll display the help for that mode instead."
  553.     set pkg $v
  554.     }
  555.     if {![catch {alpha::package help $pkg} res]} {
  556.     if {[lindex [set help [lindex $res 1]] 0] == "file"} {
  557.         if {$pointer} {
  558.         return "Help for this package is located in \"[lindex $help 1]\""
  559.         } else {
  560.         edit -r -c [file join ${HOME} Help [lindex $help 1]]
  561.         }
  562.     } elseif {[string index $help 0] == "\["} {
  563.         if {$pointer} {
  564.         return "You can read help for this package by holding 'shift' when\ryou select its name in the menu."
  565.         } else {
  566.         uplevel \#0 [string range $help 1 [expr {[string length $help] - 2}]]
  567.         }
  568.     } else {
  569.         if {$pointer} {
  570.         return $help
  571.         } else {
  572.         new -n "* '$pkg' Help *" -info \
  573.           "Help for package '$pkg', version [alpha::package versions $pkg]\r$help"
  574.         }
  575.     }
  576.     return
  577.     }
  578.     if {!$pointer} {
  579.     alertnote "Sorry, there isn't a help file for that package. You should contact the package maintainer."
  580.     }
  581.     return
  582. }
  583.  
  584. ## 
  585.  # -------------------------------------------------------------------------
  586.  # 
  587.  # "package::helpFilePresent" --
  588.  # 
  589.  #  Help files must be of the same name as the package (minus 'mode' or 
  590.  #  'menu'), but may have any combination of mode, menu, or help after
  591.  #  that name.  Whitespace is irrelevant.
  592.  # -------------------------------------------------------------------------
  593.  ##
  594. proc package::helpFilePresent {args} {
  595.     set res ""
  596.     cache::read index::help
  597.     foreach pkg $args {
  598.     lappend res [info exists index::help($pkg)]
  599.     }
  600.     return $res
  601. }
  602.  
  603. proc package::helpOrDescribe {pkg} {
  604.     if {[set mods [expr {[getModifiers] & 0xfe}]]} {
  605.     if {$mods & 34} {
  606.         package::helpFile $pkg
  607.     } else {
  608.         package::describe $pkg
  609.     }
  610.     return 1
  611.     }
  612.     return 0
  613. }
  614.  
  615. # ◊◊◊◊ Specific to 'features' ◊◊◊◊ #
  616.  
  617. proc package::addRelevantMode {_feature mode} {
  618.     global index::feature
  619.     if {[info exists index::feature($_feature)]} {
  620.     if {[lsearch -exact [set oldm [lindex [set index::feature($_feature)] 1]] $mode] != -1} {
  621.         return
  622.     }
  623.     lappend oldm $mode
  624.     set index::feature($_feature) \
  625.       [lreplace [set index::feature($_feature)] 1 1 $oldm]
  626.     } else {
  627.     set index::feature($_feature) [list [list "mode" $mode] $mode]
  628.     }
  629. }
  630.  
  631. proc package::removeRelevantMode {_feature mode} {
  632.     global index::feature
  633.     if {[info exists index::feature($_feature)]} {
  634.     if {[set idx [lsearch -exact [set oldm [lindex [set index::feature($_feature)] 1]] $mode]] == -1} {
  635.         return
  636.     }
  637.     set oldm [lreplace $oldm $idx $idx ""]
  638.     set index::feature($_feature) \
  639.       [lreplace [set index::feature($_feature)] 1 1 $oldm]
  640.     }
  641. }
  642.  
  643. ## 
  644.  # -------------------------------------------------------------------------
  645.  # 
  646.  # "package::onOrOff" --
  647.  # 
  648.  #  Complicated procedure to accomplish a relatively simple task!
  649.  #  
  650.  #  Given a list of packages from chosen in a dialog, possibly with
  651.  #  '-' prefixes to indicate 'off', work out what changes have to
  652.  #  be made to the set of on/off features to synchronise everything.
  653.  #  
  654.  #  If 'global' that means the list was of the global packages rather
  655.  #  than those for the current mode.
  656.  # -------------------------------------------------------------------------
  657.  ##
  658. proc package::onOrOff {pkgs {lastMode ""} {global 0}} {
  659.     global mode::features global::features
  660.     set oldfeatures ""
  661.     set offfeatures ""
  662.     set onfeatures ""
  663.     set newfeatures ""
  664.     foreach m $pkgs {
  665.     if {[string index $m 0] == "-"} {
  666.         set m [string range $m 1 end]
  667.         if {[lsearch -exact ${global::features} $m] >= 0} {
  668.         lappend offfeatures $m
  669.         }
  670.     } else {
  671.         if {[lsearch -exact ${global::features} $m] < 0} {
  672.         lappend newfeatures $m
  673.         }
  674.     }
  675.     }
  676.     if {$global} {
  677.     # turn off those which aren't there
  678.     set offfeatures [lremove -l [set global::features] $pkgs]
  679.     }
  680.     if {[info exists mode::features($lastMode)]} {
  681.     foreach m [set mode::features($lastMode)] {
  682.         if {[string index $m 0] == "-"} {
  683.         set m [string range $m 1 end]
  684.         if {$global} {
  685.             lappend oldfeatures $m
  686.         } else {
  687.             if {[lsearch -exact ${global::features} $m] >= 0} {
  688.             if {[set ip [lsearch -exact $offfeatures $m]] < 0} {
  689.                 lappend newfeatures $m
  690.             } else {
  691.                 set offfeatures [lreplace $offfeatures $ip $ip]
  692.             }
  693.             }
  694.         }
  695.         } else {
  696.         if {$global} {
  697.             if {[set ip [lsearch -exact $offfeatures $m]] >= 0} {
  698.             set offfeatures [lreplace $offfeatures $ip $ip]
  699.             }
  700.         } else {
  701.             if {[lsearch -exact ${global::features} $m] < 0} {
  702.             lappend oldfeatures $m
  703.             if {[lsearch -exact $newfeatures $m] < 0} {
  704.                 lappend offfeatures $m
  705.             }
  706.             }
  707.         }
  708.         }
  709.     }
  710.     }
  711.     foreach m $newfeatures {
  712.     if {[lsearch -exact $oldfeatures $m] < 0} {
  713.         lappend onfeatures $m
  714.     }
  715.     }
  716.     return [list $offfeatures $onfeatures]
  717. }
  718.  
  719. proc package::partition {{mode ""}} {
  720.     global index::feature
  721.     set a ""
  722.     set b ""
  723.     set c ""
  724.     if {$mode == ""} {
  725.     # global case
  726.     foreach n [lsort -ignore [alpha::package names]] {
  727.         if {[info exists index::feature($n)]} {
  728.         switch -- [lindex [set index::feature($n)] 2] {
  729.             "1" {
  730.             lappend a $n
  731.             }
  732.             default {
  733.             lappend b $n
  734.             }
  735.         }
  736.         } else {
  737.         lappend c $n
  738.         }
  739.     }
  740.     return [list $a $b $c]
  741.     } else {
  742.     set d ""
  743.     set e ""
  744.     set f ""
  745.     set partition [array names index::feature]
  746.     if {$mode == "global"} {
  747.         set mode "global*"
  748.         set search "-glob"
  749.     } else {
  750.         set search "-exact"
  751.         global global::features
  752.         set partition [lremove -l $partition ${global::features}]
  753.     }        
  754.     foreach n [lsort -ignore $partition] {
  755.         set ff [set index::feature($n)]
  756.         switch -- [lindex $ff 2] {
  757.         "1" {
  758.             if {[lsearch $search [lindex $ff 1] $mode] != -1} {
  759.             lappend a $n
  760.             } elseif {[lsearch -exact [lindex $ff 1] "global"] != -1} {
  761.             lappend b $n
  762.             } elseif {[lindex $ff 1] != "global-only"} {
  763.             lappend c $n
  764.             }
  765.         }
  766.         "0" {
  767.             if {[lsearch $search [lindex $ff 1] $mode] != -1} {
  768.             lappend d $n
  769.             } elseif {[lsearch -exact [lindex $ff 1] "global"] != -1} {
  770.             lappend e $n
  771.             } elseif {[lindex $ff 1] != "global-only"} {
  772.             lappend f $n
  773.             }
  774.         }
  775.         }
  776.     }
  777.     return [list $a $b $c $d $e $f]
  778.     }    
  779. }
  780.  
  781.  
  782. proc package::describe {pkg {return 0}} {
  783.     set info [alpha::package info $pkg]
  784.     set type [lindex $info 0]
  785.     set v [alpha::package versions $pkg]
  786.     if {[lindex $v 0] == "mode"} {
  787.     set v [lindex $v 1]
  788.     set msg "Package '$pkg', designed for use by $v mode is a"
  789.     } else {
  790.     set msg "Package '$pkg', version $v is a"
  791.     }
  792.     
  793.     switch -- $type {
  794.     "feature" {
  795.         switch -- [lindex $info 3] {
  796.         "0" {
  797.             append msg " $type, and is [package::active $pkg {active inactive}]."
  798.         }
  799.         "1" {
  800.             append msg " menu, and is "
  801.             global global::menus
  802.             if {![lcontains global::features $pkg]} {
  803.             append msg "not "
  804.             }
  805.             append msg "in use."
  806.         }
  807.         "-1" {
  808.             append msg "n autoloading $type."
  809.         }
  810.         }
  811.     }
  812.     "mode" {
  813.         append msg " $type; modes are always active."
  814.     }
  815.     }
  816.     cache::read index::maintainer
  817.     if {[info exists index::maintainer($pkg)]} {
  818.     set p [lindex [set index::maintainer($pkg)] 1]
  819.     append msg "\rMaintainer: [lindex $p 0], [lindex $p 1]\r"
  820.     append msg [lindex $p 2]
  821.     }
  822.     if {$return} {
  823.     return $msg
  824.     }
  825.     # let package tell us where its prefs are stored.
  826.     global alpha::prefs
  827.     if {[info exists alpha::prefs($pkg)]} {
  828.     set pkgpref [set alpha::prefs($pkg)]
  829.     } else {
  830.     set pkgpref $pkg
  831.     }
  832.     global ${pkgpref}modeVars
  833.     if {[array exists ${pkgpref}modeVars]} {
  834.     append msg "\r\r" [mode::describeVars $pkg $pkgpref]
  835.     new -n "* <$pkg> description *" -m Tcl -info $msg
  836.     } else {
  837.     alertnote $msg
  838.     }
  839. }
  840.  
  841. proc package::deactivate {pkg} {
  842.     global index::feature
  843.     try::level \#0 [lindex [set index::feature($pkg)] 5] -reporting log -while "deactivating $pkg"
  844. }
  845.  
  846. proc package::activate {pkg} {
  847.     global index::feature
  848.     if {[set init [lindex [set index::feature($pkg)] 3]] != ""} {
  849.     message "Loading package '$pkg'…"
  850.     try::level \#0 $init -reporting log -while "initialising $pkg" 
  851.     set index::feature($pkg) [lreplace [set index::feature($pkg)] 3 3 ""]
  852.     }
  853.     try::level \#0 [lindex [set index::feature($pkg)] 4] -reporting log -while "activating $pkg"
  854. }
  855.  
  856. proc package::uninstall {} {
  857.     cache::read index::uninstall
  858.     if {![llength [set pkgs [array names index::uninstall]]]} {
  859.     alertnote "I don't know how to uninstall anything."
  860.     return
  861.     }
  862.     set pkgs [listpick -p "Permanently remove which packages/modes/menus?" -l [lsort -ignore $pkgs]]
  863.     if {![llength $pkgs]} { return }
  864.     if {![dialog::yesno "Are you absolutely sure you want to uninstall [join $pkgs {, }]?"]} { 
  865.     return 
  866.     }
  867.     global pkg_file
  868.     foreach pkg $pkgs {
  869.     set pkg_file [lindex [set index::uninstall($pkg)] 1]
  870.     set script [lindex [set index::uninstall($pkg)] 2]
  871.     if {[regexp "rm -r\[^\r\n\]*" $script check]} {
  872.         if {![dialog::yesno "The uninstaller for $pkg contains a\
  873.           recursive removal command '$check'. Do you want to do this?"]} { 
  874.         return 
  875.         }
  876.     }
  877.     if {[catch "uplevel \#0 [list $script]"]} {
  878.         alertnote "The uninstaller for $pkg had problems!"
  879.     }
  880.     }
  881.     if {[dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  882.     quit
  883.     }
  884.     if {[dialog::yesno "All indices must then be rebuilt.\rShall I do this for you?"]} {
  885.     alpha::rebuildPackageIndices
  886.     rebuildTclIndices
  887.     } else {
  888.     alertnote "This will probably cause problems."
  889.     }
  890.     if {[dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  891.     quit
  892.     }
  893. }
  894.  
  895. ## 
  896.  # -------------------------------------------------------------------------
  897.  # 
  898.  # "date::isOlder" --
  899.  # 
  900.  #  {Aug 22 1996} {Mar 26 22:17}
  901.  #  
  902.  # We assume the format is 'Month Day Year' or 'Month Day Time', where
  903.  # a time is distinguished by the presence of a colon.  Months have
  904.  # to be the standard three letter abbreviation (seems ok for all
  905.  # ftp and http servers I've come across)
  906.  # -------------------------------------------------------------------------
  907.  ##
  908. proc date::isOlder {a b} {
  909.     if {$a == $b} { return 0 }
  910.     regexp {(\w+)[ \t]+(\w+)[ \t]+((\w|:)+)} $a "" am ad ay
  911.     regexp {(\w+)[ \t]+(\w+)[ \t]+((\w|:)+)} $b "" bm bd by
  912.     # check year
  913.     regexp {[0-9]+$} [lindex [mtime [now] abbrev] 0] thisy
  914.     if {$ay == $thisy} { set ay "00:00" }
  915.     if {$by == $thisy} { set by "00:00" }
  916.     set a_ist [regexp : $ay]
  917.     set b_ist [regexp : $by]
  918.     if {!$a_ist && !$b_ist} {
  919.     if { $ay < $by } { return 1 } elseif {$by < $ay} { return 0}
  920.     }
  921.     if {$a_ist && !$b_ist} { return 0 }
  922.     if {!$a_ist && $b_ist} { return 1 }
  923.     # both are a year or both are times and both in last year
  924.     set months {Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}
  925.     # check we don't have a year wrap-around problem
  926.     set now [lindex [mtime [now] short] 0]
  927.     set refdate [lindex [mtime 2976439308 short] 0]
  928.     if {$refdate == "4/26/98"} {
  929.     # US
  930.     regexp {([0-9]+)/([0-9]+)} $now "" now_m now_d
  931.     } elseif {$refdate == "98-04-26"} {
  932.     # Swedish
  933.     regexp {[0-9]+-([0-9]+)-([0-9]+)} $now "" now_m now_d
  934.     } else {
  935.     # Other
  936.     regexp {([0-9]+)[-/\.]([0-9]+)} $now "" now_d now_m
  937.     }
  938.     set am [lsearch $months $am]
  939.     set bm [lsearch $months $bm]
  940.     set aprev [expr {($now_m < $am || ($now_m == $am && $now_d < $ad))}]
  941.     set bprev [expr {($now_m < $bm || ($now_m == $bm && $now_d < $bd))}]
  942.     if {$aprev && !$bprev} {return 1}
  943.     if {!$aprev && $bprev} {return 0}
  944.     # both in same year: continue
  945.     if {$am < $bm} { return 1 } elseif {$bm < $am} { return 0 }
  946.     if {$ad < $bd} { return 1 } elseif {$bd < $ad} { return 0 }
  947.     if {$a_ist && $b_ist} {
  948.     regsub {:} $ay {.} ay
  949.     regsub {:} $by {.} by
  950.     if { $ay < $by } { return 1 } elseif {$by < $ay} { return 0}
  951.     } 
  952.     # same !
  953.     return 0
  954. }
  955.  
  956.  
  957. # ◊◊◊◊ Handle remote menu ◊◊◊◊ #
  958. proc package::menuProc {menu item} {
  959.     global remote::site modifiedArrVars defaultAlphaDownloadSite
  960.     switch -- $item {
  961.     "Describe A Package" {
  962.         set pkg [dialog::optionMenu "Describe which package?" \
  963.           [lsort -ignore [alpha::package names]]]
  964.         package::describe $pkg
  965.     }
  966.     "Read Help For A Package" {
  967.         set pkg [dialog::optionMenu "Read help for which package?" \
  968.           [lsort -ignore [alpha::package names]]]
  969.         package::helpFile $pkg
  970.     }
  971.     "Uninstall Some Packages" {
  972.         package::uninstall
  973.     }
  974.     "rebuildPackageIndex" {
  975.         alpha::rebuildPackageIndices
  976.     }
  977.     "listPackages" {
  978.         global::listPackages
  979.     }
  980.     "installBugFixesFrom" {
  981.         # this item isn't in the menu by default anymore.
  982.         set f [getfile "Select a bug-fix file…"]
  983.         procs::patchOriginalsFromFile $f 1
  984.     }
  985.     "Update List From A Web Archive Site" {
  986.         package::queryWebForList
  987.     }
  988.     "Ok, Got The List" {
  989.         package::okGotTheList
  990.     }
  991.     "Add Web Or Ftp Archive Site" {
  992.         array set remote::site [package::_editSite]
  993.         lappend modifiedArrVars remote::site
  994.     }
  995.     "Edit Web Or Ftp Archive Site" {
  996.         set sitename [dialog::optionMenu "Edit which site?" \
  997.           [lsort -ignore [array names remote::site]]]
  998.         
  999.         array set remote::site \
  1000.           [package::_editSite $sitename [set remote::site($sitename)]]
  1001.         lappend modifiedArrVars remote::site
  1002.     }
  1003.     "Remove Web Or Ftp Archive Site" {
  1004.         set sitename [dialog::optionMenu "Remove which site?" \
  1005.           [lsort -ignore [array names remote::site]]]
  1006.         unset remote::site($sitename)
  1007.         lappend modifiedArrVars remote::site
  1008.     }
  1009.     "Describe Item" {
  1010.         alertnote "Select one of the packages, and I'll tell you\
  1011.           when it was last modified, and from where it would be downloaded."
  1012.     }
  1013.     "Ignore Item" {
  1014.         alertnote "'Ignoring' a package tells me to remove it from\
  1015.           new and updated package lists.  It'll still be listed lower\
  1016.           down in the menu"
  1017.     }
  1018.     "Select Item To Download" {
  1019.         alertnote "Select one of the packages, and it will be\
  1020.           downloaded from its site on the internet, decompressed\
  1021.           and installed."
  1022.     }
  1023.     default {
  1024.         remote::get $item
  1025.     }
  1026.     }
  1027.     
  1028. }
  1029.  
  1030.  
  1031. proc package::makeUpdateMenu {} {
  1032.     global remote::listing
  1033.     set l [list \
  1034.       "Update List From A Web Archive Site…" \
  1035.       "(Ok, Got The List" \
  1036.       "<E<SRemove Web Or Ftp Archive Site…" \
  1037.       "<S<BEdit Web Or Ftp Archive Site…" \
  1038.       "<SAdd Web Or Ftp Archive Site…" "(-" \
  1039.       "<S[menu::itemWithIcon {Describe Item} 81]" \
  1040.       "<S<U[menu::itemWithIcon {Ignore Item} 81]" \
  1041.       "<S[menu::itemWithIcon {Select Item To Download} 81]" ]
  1042.     foreach a ${remote::listing} {
  1043.     set type [lindex $a 1]
  1044.     regsub -all {\.(sit|bin|hqx)} [lindex $a 2] "" name
  1045.     lappend [lindex {other gone new uptodate update} [expr {$type + 2}]] $name
  1046.     if {$type == -1} {
  1047.         lappend disable $name
  1048.     }
  1049.     }
  1050.     if {[info exists update]} {
  1051.     lappend l "(-" "/\x1e(Updated items^[text::Ascii 79 1]"
  1052.     eval lappend l [lsort -ignore $update]
  1053.     }
  1054.     if {[info exists new]} {
  1055.     lappend l "(-" "/\x1e(New items^[text::Ascii 79 1]"
  1056.     eval lappend l [lsort -ignore $new]
  1057.     }
  1058.     if {[info exists uptodate]} {
  1059.     lappend l "(-" "(Current items"
  1060.     eval lappend l [lsort -ignore $uptodate]
  1061.     }
  1062.     if {[info exists other]} {
  1063.     lappend l "(-" "(Other items"
  1064.     eval lappend l [lsort -ignore $other]
  1065.     }
  1066.     if {[info exists gone]} {
  1067.     lappend l "(-" "(Vanished items"
  1068.     eval lappend l [lsort -ignore $gone]
  1069.     }
  1070.     Menu -n "internetUpdates" -m -p package::menuProc $l
  1071.     if {[info exists disable]} {
  1072.     foreach a $disable {
  1073.         enableMenuItem "internetUpdates" $a off
  1074.     }
  1075.     }
  1076. }
  1077.  
  1078. proc remote::processftpListing {lines} {
  1079.     set files {}
  1080.     foreach f [lrange [lreplace $lines end end] 1 end] {
  1081.     set nm [lindex $f end]
  1082.     if {[string length $nm]} {
  1083.         if {[string match "d*" $f]} {
  1084.         #lappend files "$nm/"
  1085.         } else {
  1086.         regexp {[A-Z].*$} [lreplace $f end end] time
  1087.         set date [lindex $time end]
  1088.         if {[regexp : $date] || ![regexp {^19[89][0-5]$} $date]} {
  1089.             # reject anything pre 1996
  1090.             lappend files [list $nm $time]
  1091.         }
  1092.         }
  1093.     }
  1094.     }
  1095.     return $files
  1096. }
  1097.  
  1098. ## 
  1099.  # -------------------------------------------------------------------------
  1100.  # 
  1101.  # "remote::processhttpListing" --
  1102.  # 
  1103.  #  Extract all things like  <A HREF="/~vince/pub/">Parent Directory</A>
  1104.  #  followed by a date.  Massage the date into 'Month day year'.
  1105.  #  
  1106.  #  I don't know if this will work for all http servers!  It works for
  1107.  #  mine.
  1108.  # -------------------------------------------------------------------------
  1109.  ##
  1110. proc remote::processhttpListing {lines} {
  1111.     set files {}
  1112.     foreach f $lines {
  1113.     if {[regexp {<A HREF="([^"]*)">.*</A>[ \t]*([^ \t]+)[ \t]} $f "" name date]} {
  1114.         if {![regexp {/$} $name]} {
  1115.         if {![regexp {[89][0-5]$} $date]} {
  1116.             # reject anything pre 1996
  1117.             set date [split $date -]
  1118.             set md "[lindex $date 1] [lindex $date 0] "
  1119.             append md [expr {[lindex $date 2] < 80 ? 20 : 19}]
  1120.             append md [lindex $date 2]
  1121.             lappend files [list $name $md]
  1122.         }
  1123.         }
  1124.     }
  1125.     }
  1126.     return $files
  1127. }
  1128.  
  1129. proc remote::versionOneNewer {one two} {
  1130.     return 1
  1131. }
  1132.  
  1133. proc remote::processList {sitename {l ""}} {
  1134.     global remote::listing modifiedVars
  1135.     # removed vanished items from the menu
  1136.     regsub -all {(\.|-)[0-9]+([a-zA-Z][0-9]+)?} $l "" ll
  1137.     foreach i ${remote::listing} {
  1138.     if {[string match "*${sitename}*" $i]} {
  1139.         regsub -all {(\.|-)([0-9]+([a-zA-Z][0-9]+)?)} \
  1140.           [set ii [lindex $i 2]] "" ii
  1141.         if {[lsearch -glob $ll "$ii *"] == -1} {
  1142.         # it's vanished
  1143.         lappend removed $i
  1144.         lappend _removed [lindex $i 0]
  1145.         }
  1146.     }
  1147.     }
  1148.     if {[info exists removed]} {
  1149.     set remote::listing [lremove -l ${remote::listing} $removed]
  1150.     }
  1151.     # process new items
  1152.     foreach i $l {
  1153.     set namepart [lindex $i 0]
  1154.     set timepart [lindex $i 1]
  1155.     regsub -all {\.(sit|bin|hqx)} $namepart "" name
  1156.     regsub -all {(\.|-)[0-9]+([a-zA-Z][0-9]+)?} $name "" name
  1157.     if {[set idx [lsearch -glob ${remote::listing} "${name} *"]] != -1} {
  1158.         # update old item
  1159.         set item [lindex ${remote::listing} $idx]
  1160.         if {[lindex $item 2] != $namepart} {
  1161.         # it's changed
  1162.         set item [lreplace $item 1 end 2 $namepart $timepart $sitename]
  1163.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1164.         lappend _updated $name
  1165.         } elseif {[date::isOlder [lindex $item 3] $timepart]} {
  1166.         # date has changed
  1167.         set item [lreplace $item 1 end 2 $namepart $timepart $sitename]
  1168.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1169.         lappend _updated $name
  1170.         }
  1171.     } else {
  1172.         # new package
  1173.         lappend remote::listing [list $name 0 $namepart $timepart $sitename]
  1174.         lappend _new $name
  1175.     }
  1176.     
  1177.     }
  1178.     lappend modifiedVars remote::listing
  1179.     package::makeUpdateMenu
  1180.     ensureset _updated "none"
  1181.     ensureset _new "none"
  1182.     ensureset _removed "none"
  1183.     if {[catch {alertnote "Remote information, NEW: $_new, UPDATED: $_updated, REMOVED: ${_removed}."}]} {
  1184.     alertnote "Remote information, [llength $_new] new, [llength $_updated] updated and [llength $_removed] packages removed."
  1185.     }
  1186. }
  1187. proc remote::updateDatabase {idx val} {
  1188.     global remote::listing
  1189.     set item [lindex ${remote::listing} $idx]
  1190.     if {[lindex $item 1] != $val} {
  1191.     # it's changed
  1192.     set item [lreplace $item 1 1 $val]
  1193.     set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1194.     }
  1195. }
  1196.  
  1197. proc remote::pkgIndex {name} { 
  1198.     global remote::listing
  1199.     if {[set i [lsearch -glob ${remote::listing} "${name} *"]] == -1} {
  1200.     set i [lsearch -glob ${remote::listing} \
  1201.       "[string toupper [string index ${name} 0]][string range $name 1 end] *"]
  1202.     }
  1203.     return $i
  1204. }
  1205.  
  1206. proc remote::pkgDetails {name} { 
  1207.     global remote::listing
  1208.     set idx [lsearch -glob ${remote::listing} "${name} *"]
  1209.     return [lindex ${remote::listing} $idx]
  1210. }
  1211.  
  1212. proc remote::get {pkg} {
  1213.     global remote::listing HOME remote::site downloadFolder file::separator
  1214.     # get pkg
  1215.     if {[set idx [remote::pkgIndex $pkg]] == -1} {
  1216.     alertnote "Sorry, I don't know from where to download that package."
  1217.     error ""
  1218.     }
  1219.     set item [lindex ${remote::listing} $idx]
  1220.     
  1221.     if {[set mods [expr {[getModifiers] & 0xfe}]]} {
  1222.     if {$mods & 34} {
  1223.         # just shift key demote the item in the hierarchy
  1224.         set itm [lindex $item 1]
  1225.         if {$itm == 0 || $itm == 2} { set itm 1 } else { set itm -2 }
  1226.         set item [lreplace $item 1 1 $itm]
  1227.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1228.         global modifiedVars
  1229.         lappend modifiedVars remote::listing
  1230.         package::makeUpdateMenu
  1231.         message "Package '$pkg' demoted."
  1232.         return
  1233.     } else {
  1234.         # describe the item
  1235.         alertnote "File '[lindex $item 2]', last modified [lindex $item 3], to be downloaded from [lindex $item 4], at [set remote::site([lindex $item 4])]"
  1236.         return
  1237.     }
  1238.     }
  1239.     set file [lindex $item 2]
  1240.     set sitename [lindex $item 4]
  1241.     # get the file
  1242.     if {![file exists $downloadFolder] || ![file isdirectory $downloadFolder]} {
  1243.     alertnote "Your Download Folder does not exist.  I'll download to Alpha's home directory."
  1244.     set downloadFolder $HOME
  1245.     }
  1246.     if {[catch {url::fetchFrom [set remote::site($sitename)] ${downloadFolder}${file::separator} $file} err]} {
  1247.     alertnote "Fetch error '$err'"
  1248.     error ""
  1249.     }
  1250.     set ff [file join $downloadFolder $file]
  1251.     if {![file exists $ff] || (![file writable $ff]) || (![file size $ff])} {
  1252.     dialog::alert "It looks like that application returned control to\
  1253.       me before the download was complete (otherwise there was an error)\
  1254.       -- probably Netscape/IE.\r\rWhen it's done, or if there was an error\
  1255.       hit Ok."
  1256.     }
  1257.     # update database
  1258.     remote::updateDatabase $idx 1
  1259.     package::makeUpdateMenu
  1260.     # decompress it
  1261.     file::decompress [file join ${downloadFolder} $file]
  1262.     set filepre [lindex [split $file .] 0]
  1263.     # install
  1264.     set files [glob -t TEXT -nocomplain [file join ${downloadFolder} "${filepre}*"]]
  1265.     if {[llength $files] == 0} {
  1266.     # look for directory
  1267.     set dirs [glob -nocomplain "[file join ${downloadFolder} ${filepre}*]${file::separator}"]
  1268.     if {[llength $dirs] == 1} {
  1269.         set local [lindex $dirs 0]
  1270.         set files [glob -t TEXT -nocomplain "${local}*\[i|I\]{nstall,NSTALL}"]
  1271.     } else {
  1272.         set files ""
  1273.         set local $downloadFolder
  1274.     }
  1275.     }
  1276.     if {[llength $files] == 0} {
  1277.     alertnote "I can't find a suitable, unique install file.  You must find it yourself."
  1278.     # open dir in finder
  1279.     openFolder $local
  1280.     return
  1281.     }
  1282.     if {[llength $files] > 1} {
  1283.     set f [listpick -p "Which file is the installer?" $files]
  1284.     } else {
  1285.     set f [lindex $files 0]
  1286.     }
  1287.     edit $f
  1288.     global mode
  1289.     if {$mode != "Inst"} {
  1290.     alertnote "I don't know what to do with this package from here."
  1291.     } else {
  1292.     if {[dialog::yesno "You can install this extension from the install menu.\rShall I do that for you?"]} {
  1293.         install::installThisPackage
  1294.     }
  1295.     }
  1296. }
  1297.  
  1298.  
  1299.  
  1300.  
  1301.  
  1302.  
  1303.  
  1304.  
  1305.  
  1306.